;;AUG99 ANALYZE.LSP
;;;;;;;;;;;;;;;;;; INIT.LSP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;must be used with chess.lsp VERS2.0
;;NICK K. VAN VLIET SEPT. 1996
;;
;;You'll have to forgive me; it was a challenge;
;;but it's almost too difficult for me to figure out
;;and I already had a COM done so I quit without
;;finalizing a menu for boards - it worked!
;;A pretty printing loop is done 1st and
;;then each board is analised!
(setq zzz '( ;;WHITE @ BOTTOM=+1=PEEK[0]
+1 255 255 255 255 255 255 255;;[
255 255 ;;off board WHITE bottom
;; 0 1 2 3 4 5 6 7 8 9
255 255 255 255 255 255 255 255 255 255 ;;off board
;; 10 11 12 13 14 15 16 17 18 19 #
255 255 255 255 255 255 255 255 255 255 ;;off board 22
;; 20 21 22 23 24 25 26 27 28 29 #
;;------------------------------------------------
;; r n b q k b n r off off ;; 8 black pieces
;-114 -110 -98 -113 -107 -98 -110 -114 255 255
;; 0 0 0 0 -113 0 82 0 255 255 ;;<1
0 0 0 0 0 0 0 -107 255 255 ;;<<<
;; 30 31 32 33 34 35 36 37 38 39 #
;; p p p p p p p p off off ;; 7 black pawns
;; 80 -112 0 0 -112 0 -112 -112 255 255
;; 0 0 0 0 0 0 0 -107 255 255 ;;<1
0 0 0 0 0 -112 0 66 255 255 ;;<<<
;; 40 41 42 43 44 45 46 47 48 49 #
;;------------------------------------------------
;; 0 0 -112 0 0 0 0 0 255 255 ;; 6 blank sq
;; 0 0 0 0 0 0 82 0 255 255 ;;<1
0 0 0 0 0 -112 0 0 255 255 ;;<<<
;; 50 51 52 53 54 55 56 57 58 59 #
;; 0 0 0 80 0 0 0 0 255 255 ;; 5 blank sq
;; 0 0 0 0 0 66 0 75 255 255 ;;<1
0 0 0 0 0 78 0 0 255 255 ;;<<<
;; 60 61 62 63 64 65 66 67 68 69 #
;;===============================================================
;; 0 0 0 0 0 0 0 66 255 255 ;; 4 blank sq
;; 0 0 0 0 78 0 81 0 255 255 ;;<1
0 0 0 0 0 0 0 0 255 255 ;;<<<
;; 70 71 72 73 74 75 76 77 78 79 #
;; 81 0 0 0 82 0 0 0 255 255 ;;3 blank sq
;; 0 0 -112 0 0 0 0 0 255 255 ;;<1
0 0 0 0 0 0 0 0 255 255 ;;<<<
;; 80 81 82 83 84 85 86 87 88 89 #
;;------------------------------------------------
;; P P P P P P P P off off ;;2 white pawns
;; 0 80 80 0 80 80 80 80 255 255
;; 0 0 0 -112 0 0 0 0 255 255 ;;<1
0 75 0 0 0 0 0 0 255 255 ;;<<<
;; 90 91 92 93 94 95 96 97 98 99 #
;; R N B Q K B N R off off ;;1 white pieces
;; 82 78 66 81 75 66 78 82 255 255
;; 0 0 0 0 0 0 0 0 255 255 ;;<1
82 0 0 0 0 0 0 0 255 255 ;;<<<
;;100 101 102 103 104 105 106 107 108 109 #
;;------------------------------------------------
255 255 255 255 255 255 255 255 255 255 ;;off board 24
;;110 111 112 113 114 115 116 117 118 119 #
255 255 255 255 255 255 255 255 255 255 ;;off board
;;120 121 122 123 124 125 126 127 128 129 #
255 255 ;;] ;;off board NIGHT_MOVES
;;---------------------------------on/off-on/off---------
;; 1/0 1/0
;; bot-kg top-kg auto comp level data a.c
0 0 0 0 0 +1 1 1 ;;computer-on-bottom:+1.1
;;130 131 132 133 134 135 136 137 138 139 #
;;-----------------------top/bot-----------------
;; top -1/+1 bot
;;wht blk wht2 blk2 tep turn bep level data
126 0 126 0 0 1 62 3 0 0
;;140 141 142 143 144 145 146 147 148 149 #
;;-----altered move!------display move------------
;;from id to id from id to id data
42 -112 62 -112 42 -112 62 -112 0 0
;;150 151 152 153 154 155 156 157 158 159 #
;;------------------------------------------------
;; -pin +pin
0 0 0 0 nil 0 nil 0 0 0
;;160 161 162 163 164 165 166 167 168 169 # No.s len=170
;;------------------------------------------------
))
;;neg top/pos bot-always []
;;white=bot=+1/top=-1 [0]
;;auto=comptr = 't [137] ;;if peek[137]='t bottom has 1st move
;;manual=player1= nil [137]
;;computer-on='t [138] ;;if peek[138]='t white has 1st move
;;turn top=-1/bot=+1 [145]
;;white's-turn == if peek[0]=peek[145]
;; or if peek[140]=126=80h player
;; or if peek[142]=126=80h computer
;;computer white-turn peek[142]=126 & peek[137]='t if peek[0]=+1 >>bot+1 [145]
;; " black-turn peek[142]= 0 & peek[137]='t if peek[0]=+1 >>top-1 [145]
(setq zl (length zzz)) ;;180
(setq zzz2 '( ;;WHITE @ TOP=-1=PEEK[0]
-1 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
;;------------------------------------------------
;; R N B Q K B N R white chessmen
-82 -78 -66 -81 -75 -66 -78 -82 255 255
;; P P P P P P P P
-80 -80 -80 -80 -80 -80 -80 -80 255 255
0 0 0 0 0 0 0 0 255 255
0 0 0 0 0 0 0 0 255 255
0 0 0 0 0 0 0 0 255 255
0 0 0 0 0 0 0 0 255 255
;; p p p p p p p p
112 112 112 112 112 112 112 112 255 255
;; r n b q k b n r black chessmen
114 110 98 113 107 98 110 114 255 255
;;------------------------------------------------
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
255 255 0 0 0 0 0 +1 nil 3
126 0 126 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 ;;data
0 0 0 0 0 0 0 0 0 0 ;;data
;;160 161 162 163 164 165 166 167 168 169 No.s len=170
))
(defun pr(x &rest y)
(apply #'format 't x y)
)
(unless (fboundp 'while)
(defmacro while (test &rest forms)
`(do () ((not ,test)) ,@forms))
)
(unless(fboundp 'strcat)
(defun strcat (&rest str)
(apply #'concatenate 'string str)
))
(unless (fboundp 'incf)
(defmacro incf (var &optional (delta 1))
`(setf ,var (+ ,var ,delta))
)
)
(unless (fboundp 'decf)
(defmacro decf (var &optional (delta 1))
`(setf ,var (- ,var ,delta))
)
)
(unless (fboundp 'push)
(defmacro push (v l)
`(setf ,l (cons ,v ,l))
)
)
(unless (fboundp 'pushnew)
(defmacro pushnew (a l &rest args)
`(unless (member ,a ,l ,@args) (push ,a ,l) nil)
)
)
(unless (fboundp 'pop)
(defmacro pop (l)
`(prog1 (first ,l) (setf ,l (rest ,l)))
)
)
(unless (fboundp 'popend)
(defmacro popend (l)
`(prog1 (first(reverse ,l)) (setf ,l (reverse (rest (reverse ,l)))))
)
)
(defun equalp (x y)
(cond
((equal x y) t)
((numberp x) (if (numberp y) (= x y) NIL))
((characterp x) (if (characterp y) (char-equal x y) NIL))
((and (or (arrayp x) (stringp x))
(or (arrayp y) (stringp y))
(eql (length x) (length y))
)
(every #'equalp x y)
)
(t nil)
)
)
(defun unintern (symbol)
(let
((subhash (hash symbol (length *obarray*))))
(cond
((member symbol (aref *obarray* subhash))
(setf (aref *obarray* subhash)
(delete symbol (aref *obarray* subhash)))
t
)
(t nil)
)
)
)
;;(typep 'x 'symbol) => t pg814
;;(typep "x" 'symbol) => nil
(defun rrynt (x &optional (y 0 s) &key (s1 0) s2)
;; array.array-fill.:key-val.start.end
(when (null s2) (setf s2 (length x)))
(do((i s1 (1+ i)))((>= i s2) x)
(setf (elt x i) y)
)
)
;(setf ls '(a b c d)) ;pg275
;(setf (elt ls 2)3) ;=> 3
;ls => (a b 3 d)
;(elt '(a b c d) 1) ;=> b
;(elt "abcd" 2) ;=> c
;(nth 2 '(a b c d)) ;=> c
;(setf (nth 1 ls) 'c) ;=> (a c 3 d)
;ls ;=> (a c 3 d)
;(nthcdr 2 ls) ;=> (3 d)
;(subseq "Nick" 2 2) ;=> ic
;(subseq "Nick" 2) ;=> ck
(defun replace (sequence1 sequence2 &key (start1 0) end1 (start2 0) end2)
(when (null end1) (setf end1 (length sequence1)))
(when (null end2) (setf end2 (length sequence2)))
(if(and(eq sequence1 sequence2)
(> start1 start2)
)
(do* ((i 0 (1+ i))
(l (if(<(- end1 start1)(- end2 start2))
(- end1 start1) (- end2 start2))
)
(s1 (+ start1 (1- l)) (1- s1))
(s2 (+ start2 (1- l)) (1- s2))
)
((>= i l) sequence1)
(setf (elt sequence1 s1) (elt sequence2 s2))
)
(do ((i 0 (1+ i))
(l (if(<(- end1 start1)(- end2 start2))
(- end1 start1)(- end2 start2))
)
(s1 start1 (1+ s1))
(s2 start2 (1+ s2))
)
((>= i l) sequence1)
(setf (elt sequence1 s1) (elt sequence2 s2))
)
)
)
(defun fnf(&optional x w (y fctr s))
;; add.board.fctr
(+ (if x (if w (- x 30) x) 0) 40 (* 40 y))
)
(defun fnr(x)
(if(numberp x)(if(= x 0) 0 (/ x (abs x))) nil)
)
;;==
(defun sp()(princ " "))
(defun nl()(terpri))
(defun pa()
(do((i 1(1+ i)))((> i 26))
(goto-xy 0 24) ;;char col x row y 40x24
(nl)
)
)
(defun typ(x)
(if wr (setq f(open x)))
(do((i 0(1+ i)))((eq i 'eof))(princ(read-line f))(nl))
)
(defun grid(x y &optional (z 30 s))(+ z(*(- y 1) 10)(- x 1)))
;;------------------------------------------------------------
;;[setq *jmps* '[0 12 15 10 1 6 6]] ;; -22 -21 -20 -19 -18
;;[setq *ffst* '[0 1 2 3 4 5 6]] ;; -12 -11 -10 -9 -8 ;jump-ray
;;[setq *value* '[0 1 3 3 5 9 25]] ;; -2 -1 0 1 2
;; ;; 8 9 10 11 12
;; p b n r q k ;; 18 19 20 21 22
;;------------------------------------------------------------
(setq *jmplst* '( ;;jump-list WHITE-BOTTOM
;; val jmps drctn' table
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
( 0 nil emptysq)
( 255 nil offside)
;; PAWN epx epx diagon str ep -move
( 80 2 6 1 -1 1 -9 -11 -10 -20 10 wpawn)
;; pawn epx epx diagon str ep -move
(-112 -2 6 1 -1 1 9 11 10 20 -10 -bpawn)
;; BISHOP
( 66 3 4 8 -9 11 9 -11 wbishop)
;; b
(-98 -3 4 8 -9 11 9 -11 -bbishop)
;; NIGHT
( 78 4 8 1 -19 -8 12 21 19 8 -12 -21 wnight)
;; n
(-110 -4 8 1 -19 -8 12 21 19 8 -12 -21 -bnight)
;; ROOK
( 82 5 4 8 -10 1 10 -1 wrook)
;; r
(-114 -5 4 8 -10 1 10 -1 -brook)
;; QUEEN
( 81 6 8 8 -10 -9 1 11 10 9 -1 -11 wqueen)
;; q
(-113 -6 8 8 -10 -9 1 11 10 9 -1 -11 -bqueen)
;; KING +2 castleing il ir castles
( 75 7 10 1 -10 -9 11 10 9 -11 1 -1 -2 2 3 2 -4 3 wking)
;; k +2 castleing il ir castles
(-107 -7 10 1 -10 -9 11 10 9 -11 1 -1 -2 2 3 2 -4 3 -bking)
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
(pin 0 -10 1 10 -1 ;;rook & queen
-9 11 9 -11 pin) ;;bishop & queen
;; val jmps drctn' table ;;WHITE-TOP
;; 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
;; PAWN epx epx diagon str ep -move
( 112 2 6 1 -1 1 -9 -11 -10 -20 10 bpawn)
;; pawn epx epx diagon str ep -move
(-80 -2 6 1 -1 1 9 11 10 20 -10 -wpawn)
;; BISHOP
( 98 3 4 8 -9 11 9 -11 bbishop)
;; b
(-66 -3 4 8 -9 11 9 -11 -wbishop)
;; NIGHT
( 110 4 8 1 -19 -8 12 21 19 8 -12 -21 bnight)
;; n
(-78 -4 8 1 -19 -8 12 21 19 8 -12 -21 -Wnight)
;; ROOK
( 114 5 4 8 -10 1 10 -1 brook)
;; r
(-82 -5 4 8 -10 1 10 -1 -Wrook)
;; QUEEN
( 113 6 8 8 -10 -9 1 11 10 9 -1 -11 bqueen)
;; q
(-81 -6 8 8 -10 -9 1 11 10 9 -1 -11 -Wqueen)
;; KING +2 castleing il ir castles
( 107 7 10 1 -10 -9 11 10 9 -11 -1 1 2 -2 3 2 4 -3 bking)
;; k +2 castleing il ir castles
(-75 -7 10 1 -10 -9 11 10 9 -11 -1 1 2 -2 3 2 4 -3 -Wking)
;;0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
))
(setq *xcptnlst* '( ;;exception-in-routines
( 0 ()()()() no-0)
(255 ()()()() no-255)
(pin ()()()() pin)
;;;0 1 2 3 4 5 6 7 8 9 10 ;;STORED
( 80 1 6 1 epx epx pm pm str ep () pawn)
(112 1 6 1 epx epx pm pm str ep () pawn)
( 66 3 4 8 () () () () bishop)
( 98 3 4 8 () () () () bishop)
( 82 5 4 8 () () () () rook)
(114 5 4 8 () () () () rook)
( 78 3 8 1 () () () () () () () () night)
(110 3 8 1 () () () () () () () () night)
( 81 9 8 8 () () () () () () () () queen)
(113 9 8 8 () () () () () () () () queen)
( 75 25 10 1 () () () () () () () () cstg cstg No No cstl cstl king)
(107 25 10 1 () () () () () () () () cstg cstg No No cstl cstl king)
;; 25 10 1 . . . . . . -1 1 2 -2 3 2 4 -3 king
;;LABEL 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 label No
)) ;;(H+2)
(setq atk '(
(-75 5 50 -5 -50 -WKing 78 );n ;top
(-107 5 50 -5 -50 -bking 110);n
(-78 5 50 -5 -50 -WNight 81 );q
(-110 5 50 -5 -50 -bnight 113);q
(-66 3 30 -3 -30 -WBishop 81 );q
(-98 3 30 -3 -30 -bbishop 113);q
(-80 30 -WPawn 81 );q
(-112 30 -bpawn 113);q
(75 5 50 -5 -50 WKing 78 );n ;bottom
(107 5 50 -5 -50 bking 110);n
(78 5 50 -5 -50 WNight 81 );q
(110 5 50 -5 -50 bnight 113);q
(66 3 30 -3 -30 Wbishop 81 );q
(98 3 30 -3 -30 bbishop 113);q
(80 -30 WPawn 81 );q
(112 -30 bpawn 113);q
))
(load "analyze.lsp")
(read-line)
(exit)
;;AUG99 ANALYZE.LSP
;;;;;;;;;;;;;;;;;; ANALYZE.LSP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun chess(&optional xxx lll);;NICK K. VAN VLIET start: SEPT/96
;;'t=screen-inverse.'t=read-chr
(if lll(read-char)) ;;remove return
;;(setq ff(open "boards" :direction :output))
;;(setq wr nil)
(setq *moves* 0 zl 170 *stack* "eof") ;;move-number
(setq zzz '( ;;BLACK @ TOP @0 = 1
1 255 255 255 255 255 255 255;;[
255 255 ;;off board WHITE bottom
;; 0 1 2 3 4 5 6 7 8 9
255 255 255 255 255 255 255 255 255 255 ;;off board
;; 10 11 12 13 14 15 16 17 18 19 #
255 255 255 255 255 255 255 255 255 255 ;;off board 22
;; 20 21 22 23 24 25 26 27 28 29 #
;;------------------------------------------------
;; r n b q k b n r off off ;; 8 black pieces
;-114 -110 -98 -113 -107 -98 -110 -114 255 255
;; 0 0 0 0 -113 0 82 0 255 255 ;;<1
0 0 0 0 0 0 0 -107 255 255 ;;<<<
;; 30 31 32 33 34 35 36 37 38 39 #
;; p p p p p p p p off off ;; 7 black pawns
;; 80 -112 0 0 -112 0 -112 -112 255 255
;; 0 0 0 0 0 0 0 -107 255 255 ;;<1
0 0 0 0 0 -112 0 66 255 255 ;;<<<
;; 40 41 42 43 44 45 46 47 48 49 #
;;------------------------------------------------
;; 0 0 -112 0 0 0 0 0 255 255 ;; 6 blank sq
;; 0 0 0 0 0 0 82 0 255 255 ;;<1
0 0 0 0 0 -112 0 0 255 255 ;;<<<
;; 50 51 52 53 54 55 56 57 58 59 #
;; 0 0 0 80 0 0 0 0 255 255 ;; 5 blank sq
;; 0 0 0 0 0 66 0 75 255 255 ;;<1
0 0 0 0 0 78 0 0 255 255 ;;<<<
;; 60 61 62 63 64 65 66 67 68 69 #
;;===============================================================
;; 0 0 0 0 0 0 0 66 255 255 ;; 4 blank sq
;; 0 0 0 0 78 0 81 0 255 255 ;;<1
0 0 0 0 0 0 0 0 255 255 ;;<<<
;; 70 71 72 73 74 75 76 77 78 79 #
;; 81 0 0 0 82 0 0 0 255 255 ;;3 blank sq
;; 0 0 -112 0 0 0 0 0 255 255 ;;<1
0 0 0 0 0 0 0 0 255 255 ;;<<<
;; 80 81 82 83 84 85 86 87 88 89 #
;;------------------------------------------------
;; P P P P P P P P off off ;;2 white pawns
;; 0 80 80 0 80 80 80 80 255 255
;; 0 0 0 -112 0 0 0 0 255 255 ;;<1
0 75 0 0 0 0 0 0 255 255 ;;<<<
;; 90 91 92 93 94 95 96 97 98 99 #
;; R N B Q K B N R off off ;;1 white pieces
;; 82 78 66 81 75 66 78 82 255 255
;; 0 0 0 0 0 0 0 0 255 255 ;;<1
82 0 0 0 0 0 0 0 255 255 ;;<<<
;;100 101 102 103 104 105 106 107 108 109 #
;;------------------------------------------------
255 255 255 255 255 255 255 255 255 255 ;;off board 24
;;110 111 112 113 114 115 116 117 118 119 #
255 255 255 255 255 255 255 255 255 255 ;;off board
;;120 121 122 123 124 125 126 127 128 129 #
255 255 ;;] ;;off board NIGHT_MOVES
;;---------------------------------on/off-on/off---------
;; 1/0 1/0
;; bot-kg top-kg auto comp level data a.c
0 0 0 0 0 +1 1 1 ;;computer-on-bottom:+1.1
;;130 131 132 133 134 135 136 137 138 139 #
;;-----------------------top/bot-----------------
;; top -1/+1 bot
;;wht blk wht2 blk2 tep turn bep level data
126 0 126 0 0 1 62 3 0 0
;;140 141 142 143 144 145 146 147 148 149 #
;;-----altered move!------display move------------
;;from id to id from id to id data
42 -112 62 -112 42 -112 62 -112 0 0
;;150 151 152 153 154 155 156 157 158 159 #
;;------------------------------------------------
0 0 0 0 0 0 0 0 0 0
;;160 161 162 163 164 165 166 167 168 169 # No.s len=170
;;------------------------------------------------
))
;;neg top/pos bot-always ]
;;auto=comptr=+1=bottom ]
;;manual=player1=+1/playr2=-1 ]
;;comptr=-1=top ]
(setq zl (length zzz))
(setq zzz2 '( ;;WHITE @ TOP @0 = 2
0 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
;;------------------------------------------------
;; R N B Q K B N R white chessmen
-82 -78 -66 -81 -75 -66 -78 -82 255 255
;; P P P P P P P P
-80 -80 -80 -80 -80 -80 -80 -80 255 255
0 0 0 0 0 0 0 0 255 255
0 0 0 0 0 0 0 0 255 255
0 0 0 0 0 0 0 0 255 255
0 0 0 0 0 0 0 0 255 255
;; p p p p p p p p
112 112 112 112 112 112 112 112 255 255
;; r n b q k b n r black chessmen
114 110 98 113 107 98 110 114 255 255
;;------------------------------------------------
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
255 255 0 0 0 0 0 +1 nil 3
126 0 126 0 0 0 0 0 0 0
0 0 0 0 0 0 0 0 0 0 ;;data
0 0 0 0 0 0 0 0 0 0 ;;data
;;160 161 162 163 164 165 166 167 168 169 No.s len=170
))
;;(goto-xy 0 0) ;;char col x row y 80x24
(princ "\n CHESS.LSP VERS2.0 9/96\n
NICK K. VAN VLIET,
PO BOX 92544,
CARLTON RPO,
TORONTO,
ONTARIO
M5A 4N9
(416) 921-4653")
(princ(strcat "\n\n HI " "from " "NICK " "!!" " "))
;;(princ (int-char 7))(princ (int-char 7))(princ (int-char 7))
;;(pr "\n\n HIT ENTER!")(read-char)
(pr "\n\n Setting up grids!")
(setq *print-case* :downcase)
(setq grdtbl (make-array zl)) ;;grid-table1
(setq grdtbl2 (make-array zl)) ;;grid-table2
(setq svdbd (make-array zl)) ;;saved-board
(setq *board* (make-array zl)) ;;main-board
(setq *cmap* (make-array 180)) ;;level 1
(setq *pmap* (make-array 180)) ;;level 2
(setq *amap* (make-array 80)) ;;level 3
(setq *smap* (make-array 80)) ;;level 3
(setq *tmap* (make-array 180)) ;;level 4
(setq *pthmap*(make-array 180)) ;;level 5
(setq *fork* (make-array 180)) ;;level 6
(rrynt grdtbl ) ;zl
(rrynt grdtbl2) ;zl ???
(rrynt svdbd ) ;zl
(rrynt *board*) ;zl
(rrynt *cmap* ) ;180
;;(rrynt *pmap* ) ;180
(rrynt *amap* ) ;80
;;(rrynt *smap* ) ;80
(rrynt *tmap* ) ;180
;;(rrynt *fork* ) ;180
;;(princ grdtbl)(read-line) ;;=> #(0 0 0 ...0);;**
;;(princ grdtbl2)(read-line) ;;=> #(0 0 0 ...0);;**
(defun fllrry(x y) ;;FILL-ARRAY-WITH-BOARD
(do((j 0(1+ j)))((>= j (length x)))
(setf(aref y j)(nth j x)) ;;main-brd
)
)
(fllrry zzz grdtbl)
(fllrry zzz *board*)
(fllrry zzz svdbd)
(defun wrtfl(x)
(setq gf(open (strcat x ".BD") :direction :output))
(princ svdbd gf)
;;(princ "\n----\n")(princ svdbd)(setf svdbd nil)
(close gf)
)
;; (wrtfl "SAVE")
;; (wrtfl "LOAD")
(defun rdfl(x)
(setq gf(open (strcat x ".BD")))
(setq *board* (read-line gf)) ;;ok
(close gf)
(princ "\n----\n")(princ *board*)(princ "\n----\n")
)
;;(rdfl "SAVE")(read-line)
(defun prntfmap(x y z)
; col.row.high/low
(goto-xy x y)
(pr "ÉÍFORKSÍÍ» ")
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(pr "º")
(do((i 1(1+ i)))((> i 8))
(setq aa (aref *fork* (grid i j z)))
;(read-line)
(if(not aa)
(princ "+")
(princ(int-char aa))
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(pr "ÈÍÍÍÍÍÍÍͼ ")
(goto-xy x (+ y h 1))
(pr " ")
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j))) ;;col label ABCDEFGH
)
(princ " ")
);;(prntfmap 28 0 0/80)
(defun kngmap(x y z)
(goto-xy x y)
(if (= z 0)(setq fctr -1)(setq fctr 1))
(pr "ÉÍKNGMAPÍ» ")
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(pr "º")
(do((i 1(1+ i)))((> i 8))
(setq aa(aref *pthmap*(grid i j z)))
(if(= aa 0)
(princ "+")
(princ(int-char aa))
;(pr "
;9.2 tmap i= ~a j= ~a aa= ~a fctr= ~a ttl= ~a new-ttl= "
; i j aa fctr ttl
;)
;; (read-line)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(pr "ÈÍESC~3,,,'=@aͼ "(car(reverse(aref *board* (+ 135 fctr)))))
;;;; ÈÍÍÍÍÍÍÍͼ
(goto-xy x (+ y h 1))
(pr " ")
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j)))
)
(princ " ")
);;(kngmap 28 0)
(defun prntmap(x y &optional w)
; col.row.row-numbering
(goto-xy x y)
(if (= w 0)
(pr "ÉÍÍTMAPÍÍ» ")
(progn(princ (strcat (if(= 126(aref *board* 140)) "W" "B") "ÉÍÍTMAPÍÍ» ")))
)
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(if (= w 0)
(pr "º")
(pr "~aº"(int-char(- 57 j)))
) ;;row label 87654321
(do((i 1(1+ i)))((> i 8))
(setq aa(aref *board*(grid i j)))
(if(= aa 0)
(princ "+")
(progn
(setq fctr(/ aa (abs aa)))
(setq ttl(+(aref *tmap*(grid i j 0))(aref *tmap*(grid i j 80))))
;(pr "
;7.1.1 tmap i= ~a j= ~a aa= ~a fctr= ~a ttl= ~a new-ttl= "
; i j aa fctr ttl
;)
(setq ttl (* fctr ttl)a ttl) ;;both:+/-
(if(and(<= a 0)(>= a -9))(setq ttl (+ 1 a(* 2(- -5 a)))))
(if(< fctr 0)
(progn ;;top -
(if(<= ttl 0)(setq ttl(- ttl 7))) ;;0-9 neg
(if(> ttl 0)(setq ttl(+ ttl 32))) ;;a-z lowr/€-¯ postv
)
(progn ;;bottom +
(if(<= ttl 0)(setq ttl(- ttl 7))) ;;0-9 neg/A-Z uppr postv
(if(> ttl 25)(setq ttl(+ ttl 85))) ;;°-ã postv
)
)
;;; (if(=(aref *cmap* (grid i j (fnf)))255)(setq ttl 57))
;;(princ ttl)(princ " ")
(princ(int-char (+ 64 ttl)))
;; (read-line)
)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(if (= w 0)(pr "ÈÍ#-NEG.ͼ ")(pr " ÈÍ#-NEG.ͼ "))
(goto-xy x (+ y h 1))
(if (= w 0)(pr " ")(pr " "))
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j)))
)
(princ " ")
);;(prntmap 28 0)
(defun prntsmap(x y)
(goto-xy x y)
(pr "ÉÍÍSMAPÍÍ» ")
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(pr "º")
(do((i 1(1+ i)))((> i 8))
(setq aa (aref *board* (grid i j)))
(if(= aa 0)
(princ "+")
(progn
(setq fctr (/ aa (abs aa)))
(setq leng(length(aref *pmap*(grid i j(fnf))))) ;;guard
(setq lene(length(aref *pmap*(grid i j(fnf nil(- fctr)))))) ;;enemy
(unless leng(setq leng 0))
(unless lene(setq lene 0))
(setq ttl(- leng lene) a ttl) ;++
(setf(aref *smap* (grid i j 0))ttl)
(if(and(<= a 0)(>= a -9))(setq ttl (+ 1 a(* 2(- -5 a))))) ;++
(if(<= ttl 0)(setq ttl(- ttl 7))) ;;0-9 neg ;++
(princ(int-char (+ 64 ttl)))
)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
;; (pr "ÈÍÍÍÍÍÍÍͼ ")
(pr "È#=killed¼ ")
(goto-xy x (+ y h 1))
(pr " ")
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j)))
)
(princ " ")
);;(prntsmap 28 0)
(defun prntamap(x y)
; col.row
(goto-xy x y)
(pr "ÉÍÍAMAPÍÍ» ")
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(pr "º")
(do((i 1(1+ i)))((> i 8))
(setq aa (aref *board* (grid i j)))
(if(= aa 0)
(princ "+")
(progn
(setq fctr (/ aa (abs aa)))
(setq leno (length(aref *pmap* (grid i j 0))))
(setq lene (length(aref *pmap* (grid i j 80))))
(setq ttl(+ leno lene))
(if(> ttl 9)(setq ttl(+ ttl 7)))
(if(> ttl 35)(setq ttl(+ ttl 6)))
;(pr "\n j= ~a i= ~a aa= ~a leno= ~a lene= ~a ttl= ~a
;cmap= ~a
;pmapl= ~a
;pmaph= ~a
;char= "
; j i aa leno lene ttl (aref *cmap* (grid i j (fnf)))
;(aref *pmap* (grid i j 0))
;(aref *pmap* (grid i j 80))
;)(read-line)
(princ(int-char (+ 48 ttl)))
(setf(aref *amap* (grid i j 0))(+ 48 ttl))
)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(pr "ÈÍÍÍÍÍÍÍͼ ")
(goto-xy x (+ y h 1))
(pr " ")
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j))) ;;col label ABCDEFGH
)
(princ " ")
);;(prntamap 28 0)
(defun prntdmap(x y &optional w) ;;attacked&guarded
;; col.row.row-numbering
(goto-xy x y) ;;char col x row y 40x24
(if (= w 0)
(pr "ÉÍÍDMAPÍÍ» ")
(progn(princ (strcat (if(= 126(aref *board* 140)) "W" "B") "ÉÍÍDMAPÍÍ» ")))
)
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(if (= w 0)
(pr "º")
(pr "~aº"(int-char(- 57 j)))
) ;;row label 87654321
(do((i 1(1+ i)))((> i 8))
(setq aa (aref *pmap* (grid i j 0))) ;attacker/guarder
(setq ab (aref *pmap* (grid i j 80))) ;guarder/attacker
(if(and(car ab)(car aa))
(if(or(= (aref *cmap* (grid i j 0))255)(=(aref *cmap* (grid i j 80))255))
(princ "±") ;pinned
(princ "Û") ;not-empty
)
(if(/=(aref *board* (grid i j))0)
(princ(int-char(abs(aref *board* (grid i j))))) ;opponent
(princ "+") ;empty
)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(if (= w 0)(pr "ÈÍÍÍÍÍÍÍͼ ")(pr " ÈÍÍÍÍÍÍÍͼ "))
(goto-xy x (+ y h 1))
(if (= w 0)(pr " ")(pr " "))
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j))) ;;col label ABCDEFGH
)
(princ " ")
);;(prntdmap 28 0 1) ;row-numbering
(defun prntpmap(x y z) ;;print-list-board
; col.row.offset
(goto-xy x y) ;;char col x row y 40x24
(pr "ÉÍÍPMAPÍÍ» ")
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(pr "º")
(do((i 1(1+ i)))((> i 8))
(setq ab (aref *pmap* (grid i j z)))
;(goto-xy 1 1)
;(pr " j= ~a i= ~a ab= ~a \n cmap>>255= ~a \n pmap>>255= ~a "
; j i ab (aref *cmap* (grid i j z)) (aref *pmap* (grid i j z))
;)(read-line)
(if(car ab)
(if(= (aref *cmap* (grid i j z))255) ;pinned
(if(member 255(aref *pmap* (grid i j z)))
(princ "±") ;pinned
(princ "Û") ;not-empty[z]
)
(princ "Û") ;not-empty[z]
)
(if(/=(aref *board* (grid i j))0)
(princ(int-char(abs(aref *board* (grid i j))))) ;opponent
(princ "+") ;empty
)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(pr "ÈÍÍÍÍÍÍÍͼ ")
(goto-xy x (+ y h 1))
(pr " ")
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j))) ;;col label ABCDEFGH
)
(princ " ")
);;(prntpmap 28 0)
(defun prntcmap(x y &optional w)
; col.row.row-numbering
(goto-xy x y) ;;char col x row y 40x24
(if (= w 0)
(pr "ÉÍÍÍCMAPÍ» ")
(progn(princ (strcat (if(= 126(aref *board* 140)) "W" "B") "ÉÍÍCMAPÍÍ» ")))
)
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(if (= w 0)
(pr "º")
(pr "~aº"(int-char(- 57 j)))
) ;;row label 87654321
(do((i 1(1+ i)))((> i 8))
(setq ab (aref *cmap* (grid i j 0))) ;z
(cond
((= ab 0)
(if(/=(aref *board* (grid i j))0)
;; (princ(int-char(abs(aref *board* (grid i j))))) ;opponent
(princ "±")
(princ "+") ;empty
)
)
((= ab 255)(princ "X")) ;pinned
(t (princ "Û")) ;not-empty
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(if (= w 0)(pr "ÈÍÍÍÍÍÍÍͼ ")(pr " ÈÍÍÍÍÍÍÍͼ "))
(goto-xy x (+ y h 1))
(if (= w 0)(pr " ")(pr " "))
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j))) ;;col label ABCDEFGH
)
(princ " ")
);;(prntcmap 28 0)
(defun prntbd(z x y &optional w u)
;; inverse.col.row.row-nubering.square-optn
(goto-xy x y) ;;char col x row y 40x24
(if (= w 0)
(pr "ÉÍÍBOARDÍ» ")
(progn
(princ (strcat (if(= 126(aref *board* 142)) "W" "B") "ÉÍÍBOARDÍ» "))
)
)
(do((j 1(1+ j)))((> j 8))
(goto-xy x (+ y j))
(if (= w 0)
(pr "º")
(pr "~aº"(int-char(- 57 j)))
) ;;row label 87654321
(do((i 1(1+ i)))((> i 8))
(cond
((/=(aref *board* (grid i j))0)
(princ(int-char(abs(aref *board* (grid i j)))))
)
(t (if u ; even / odd
(princ "+") ;w1st=0/b1st=1
;;;; (if(=(+ i j)(* 2(floor (+ i j (aref *board* 145)) 2))) ;even/odd)
(if(evenp (+(if z 1 0) i j (aref *board* 0))) ;even/odd
(princ " ")
(princ "Û")
)
)
)
)
)
(princ "º ")
(setq h (+ j 1))
)
(goto-xy x (+ y h))
(if (= w 0)(pr "ÈÍÍÍÍÍÍÍͼ ")(pr " ÈÍÍÍÍÍÍÍͼ "))
(goto-xy x (+ y h 1))
(if (= w 0)(pr " ")(pr " "))
(do((j 1(1+ j)))((> j 8))
(princ(int-char(+ 64 j))) ;;col label ABCDEFGH
)
(princ " ")
);
;;(prntbd grdtbl 28 0 ) ;;char col 28 row 0
;;(prntbd grdtbl (+ 11 28) 0 't) ;;offset=11
;;(prntbd grdtbl (+ 21 28) 0 't) ;;offset=10
;;(prntbd grdtbl (+ 31 28) 0 't) ;;offset=10
;;(prntbd grdtbl (+ 41 28) 0 't) ;;offset=10
;;(prntbd grdtbl 28 11 ) ;;char col 28 row 11
;;(prntbd grdtbl (+ 11 28) 11 't) ;;offset=11
;;(prntbd grdtbl (+ 21 28) 11 't) ;;offset=10
;;(prntbd grdtbl (+ 31 28) 11 't)
;;(prntbd grdtbl (+ 41 28) 11 't)
(defun bgbrd(x y) ;;print-big-board @(0,0)
;; file.inverse-scrn
(goto-xy 0 0)
(if(= 126(aref x 140))(princ "W")(princ "B"))
(pr " ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ")
(do((j 1(1+ j)))((> j 8))
(do((k 1(1+ k)))((> k 3))
(unless (and(= j 8)(= k 3))
(if(= k 2)
(pr "\n ~aº"(int-char(- 57 j))) ;;row label 87654321
(pr "\n º")
)
(do((i 1(1+ i)))((> i 8))
(do((h 1(1+ h)))((> h 3))
(cond
((and (= k 2)(= h 2)(/=(aref x (grid i j))0))
(princ(int-char (abs (aref x (grid i j)))))
) ; even / odd
(t ;w1st=0/b1st=1
;;; (if(=(+ i j)(* 2(floor (+ y i j (aref *board* 0)) 2))) ;even/odd)
(if(evenp (+ (if y 1 0) i j (aref *board* 0))) ;even/odd
(princ " ")
(princ "Û")
)
)
)
)
)
)
(unless (and(= j 8)(= k 3))(princ "º "))
)
)
(pr "\n ÈÍAÍÍBÍÍCÍÍDÍÍEÍÍFÍÍGÍÍHͼ ")
) (bgbrd *board* xxx)
;;(bgbrd grdtbl2 xxx);;????
;;(nl)(princ (cons 2 grdtbl))
;;(nl)(princ (cons 2 grdtbl2));;????
;; Define global variables:
(defun trnslt(x) ;;translate.file-string position
(setq ln (length x))
(setq lt '( ;;NO 9 BLACK 1ST BOTTOM black 1st
2 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
)
)
(setq lb '( 255 255
255 255 255 255 255 255 255 255 255 255 ;;off board
255 255 255 255 255 255 255 255 255 255 ;;off board 22
;; auto comp level
255 255 0 0 0 0 0 -1 nil 51 ;;off board NIGHT_MOVES
;;wht blk wht2 blk2 wep w1st bep
126 0 126 0 0 0 0 0 0 0 ;;extra stored data
)
)
(setq l nil ll 51 lc nil la -1)
(do((i 0 (1+ i)))((>= i zl))
(setq aa (char-int(char x i)))
(cond
((= aa 57) ;;9 WHITE 1ST @ BOTTOM
(setq lt '(
1 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
)
)
(setq lb '( 255 255
255 255 255 255 255 255 255 255 255 255
255 255 255 255 255 255 255 255 255 255
;; p-kg c-kg auto comp level
255 255 0 0 0 0 0 +1 nil 51
;; 137 138 139
;; wht blk wht2 blk2 wep w1st bep level
126 0 126 0 0 2 0 3 0 0
;; 140 141 142 143 144 145 146 147 148 149
)
)
)
((and(> aa 47)(< aa 57)) ;;0-8
(let ((dgt (- (char-int (char x i)) 48))) ;;0-8
(dotimes (i dgt)
(setq l (cons 0 l))
)
)
)
((or(= aa 77)(= aa 109))(setq lc 0)) ;;M
((or(= aa 65)(= aa 97))(setq la -1)) ;;A
((= aa 47)(setq l(append '(255 255) l))) ;;/
((= aa 91) ;;[3
(setq i (1+ i))
(if(<= i ln)(setq ll (char-int(char x i)))(setq ll 51))
)
(t (setq l (cons (char-int(char x i)) l)))
)
)
(setq l (append lt (reverse l) lb))
(fllrry l *board*)
(setf(aref *board* 139) ll) ;;level
(setf(aref *board* 138) lc) ;;computer
(setf(aref *board* 137) la) ;;auto
)
(defun menu-init() ;;menu-init
;; 0 114 0 0 0 0 0 0 255 255 ;;board 3 on menu
;; 0 0 0 0 0 112 107 112 255 255
;; 0 0 0 0 0 0 112 0 255 255
;; 0 0 0 0 0 0 0 0 255 255
;; 0 112 0 0 0 0 0 0 255 255
;; 0 82 0 0 0 0 80 0 255 255
;; 0 0 0 0 0 80 75 80 255 255
;; 0 0 0 0 0 0 0 0 255 255
;;114 0 98 113 0 114 107 0 255 255 board 4 menu
;;112 112 0 0 0 0 112 112 255 255
;; 0 0 110 98 112 0 0 0 255 255
;; 0 0 112 112 78 112 0 0 255 255
;; 0 0 0 80 110 66 0 0 255 255
;; 0 0 80 66 80 0 0 80 255 255
;; 80 80 0 0 78 0 80 0 255 255
;; 82 0 0 81 75 0 0 82 255 255
;; 0 114 98 0 114 0 107 0 255 255 board 5 menu
;; 0 0 112 112 98 112 112 112 255 255
;;112 0 112 0 0 0 0 0 255 255
;; 0 0 0 0 0 0 0 0 255 255
;; 0 0 78 0 80 110 0 0 255 255
;; 0 78 66 0 0 0 0 0 255 255
;; 80 80 80 0 0 80 80 80 255 255
;; 82 0 0 0 82 0 75 0 255 255
(let
((slct nil)) ;;select
(pa)
(princ(strcat "\n\n HI " "from " "NICK " "!!" " \n\n"))
(princ (int-char 7))(princ (int-char 7))(princ (int-char 7))
(goto-xy 0 0)
(pr "\n OPTIONS\n")
(pr "\n Load a board........................1" )
(pr "\n User chosen position................2" )
(pr "\n Rook Endgame........................3" )
(pr "\n Z.Polgar-V.Salov,Madrid 1992........4" )
(pr "\n O.Duras-A.Alekhine,Mannheim,1914....5" )
(pr "\n New board..........................<6>")
(pr "\n Make your selection: ")
(setq slct(read-char))
(if(eql slct #\newline)(princ "6")(read-char))
(if(not(or(eql slct #\1)
(eql slct #\2)
(eql slct #\3)
(eql slct #\4)
(eql slct #\5)
)
)
(eql slct #\6)
)
(let
(pstnlst) ;;position-list
(case slct
(#\1
(pr "\n OPTIONS\n")
(pr "\n Load SAVE.BD.......................<1>")
(pr "\n Load LOAD.BD........................2" )
(pr "\n New board...........................3" )
(pr "\n Make your selection: ")
(let
((slct nil)) ;;select
(setq slct (read-char))
(if(eql slct #\newline)(princ "1")(read-char))
(if(not(or(setq slct #\2)(setq slct #\3)))(setq slct #\1))
(case slct
(#\1 (rdfl "SAVE"))
(#\2
(rdfl "LOAD")
(pr "\n OPTIONS\n")
(pr "\n ARE OPTIONS ALREADY LOADED...../N ")
(setq ans (char-int(read-char)))
(if(= ans 10)(princ "Y")(read-char))
(if(or(= ans 78)(= ans 110))(setq ans nil)(setq ans 't))
(unless ans
(pr "\n OPTIONS\n")
(pr "\n WHITE AT THE BOTTOM?......../N: ")
(let
((slct nil))
(setq slct (read-char))
(if(eql slct #\newline)(princ "Y")(read-char))
(if(or(eql slct #\N)(eql slct #\n))
(progn ;;BLACK-1st AT BOTTOM
(setf(aref *board* 139)2)
(setq *board* grdtbl2 *jmplst*);;????
)
(progn ;;WHITE-1st AT BOTTOM
(setf(aref *board* 139)1)
(setq *board* grdtbl)
)
)
)
(pr "\n OPTIONS\n")
(pr "\n WHITE TO GO FIRST?........../N: ")
(let
((slct nil))
(setq slct (read-char))
(if(eql slct #\newline)(princ "Y")(read-char))
(if(or(eql slct #\N)(eql slct #\n))
(progn ;;BLACK FIRST
(setf(aref *board* 140)0)(setf(aref *board* 141)126) ;;BK-1st
(setf(aref *board* 142)0)(setf(aref *board* 143)126)
)
(progn ;;WHITE FIRST
(setf(aref *board* 140)126)(setf(aref *board* 141) 0) ;;WT-1st
(setf(aref *board* 142)126)(setf(aref *board* 143) 0)
)
)
)
(pr "\n OPTIONS\n")
(pr "\n COMPUTER ORAK-II TO PLAY?.../N: ")
(let
((slct nil))
(setq slct (read-char))
(if(eql slct #\newline)(princ "Y")(read-char))
(if(or(eql slct #\N)(eql slct #\n))
(progn ;;BLACK FIRST
(setf(aref *board* 138)0)
)
(progn ;;WHITE FIRST
(setf(aref *board* 138)NIL)
)
)
)
)
)
(#\3
(setf(aref *board* 140)126)(setf(aref *board* 141) 0) ;;W-1st
(setf(aref *board* 142)126)(setf(aref *board* 143) 0)
(pr "\n OPTIONS\n")
(pr "\n LET COMPUTER 'ORAK-II' (TOP) GO FIRST..1 ")
(pr "\n LET PLAYER 2 (TOP) GO FIRST............2 ")
(pr "\n PLAYER 1 (BOTTOM) TO GO FIRST.........<3>")
(pr "\n Make your selection: ")
(let
((slct nil))
(setq slct (read-char))
(if(eql slct #\newline)(princ "3")(read-char))
(if(not(or(eql slct #\1)(eql slct #\2)))(setq slct #\3))
(case slct
(#\1 ;;COMPUTER/PLAYER2 FIRST - WHITE TOP
(setq *board* grdtbl2 *jmplst*);;????
(setf(aref *board* 138)nil) ;;computer activated
)
(#\2 ;;PLAYER2 FIRST - WHITE TOP
(setq *board* grdtbl2 *jmplst*);;????
) ;;upside down board
(#\3 ;;PLAYER1 FIRST - WHITE AT BOTTOM
(setq *board* grdtbl)
)
(otherwise )
)
)
)
(otherwise)
)
)
)
(#\2
(pr "\n OPTIONS\n")
(pr "\n EXAMPLE: 'A91r6/5pkp/6p1/8/1p6/1R4P1/5PKP/8[3S'\n")
(pr "\n A = AUTO DISPLAY OF LEVEL 3 MOVES / M = MANUAL.")
(pr "\n 9 = WHITE STARTS AT THE BOTTOM/ELSE BLACK.")
(pr "\n NUMBERS = NUMBER OF ZEROS IN A ROW.")
(pr "\n LETTERS = UPPER CASE - WHITE.")
(pr "\n / = END OF LINE.")
(pr "\n [3 = LEVEL 3.")
(pr "\n [3S = COMPUTER (LEVEL 3) STOPS AT CHECKMATE DISPLAYS.")
(pr "\n ENTER YOUR POSITIONS AS ABOVE:\n\n >> ")
(setq pstnlst (trnslt (read-line)))
)
(#\3
(trnslt "91r6/5pkp/6p1/8/1p6/1R4P1/5PKP/8")
)
(#\4
(trnslt "9r1bq1rk1/pp4pp/2nbp3/2ppNp2/3PnB2/2PBP2P/PP2N1P1/R2QK2R")
;;(trnslt "97k/5p1B/5p2/5N2/8/8/1K6/R7[3")
;;(trnslt "98/4p3/5p2/5k1K/2Q1Nb2/8/8/8[3") ;;1118
;;(trnslt "98/8/8/8/5k2/3q1N2/Q4K2/8[3") ;;1119
;;(trnslt "98/3p3Q/3K4/6k1/8/6B1/6P1/8[3") ;;1120
)
(#\5
(trnslt "91rb1r1k1/2ppbppp/p1p5/8/2N1Pn2/1NB5/PPP2PPP/R3R1K1")
)
(#\6 ;;138 139=1W@BOT 139=2B@BOT
(pr "\n OPTIONS\n\n")
(pr "\n MAY ORAK-II GO FIRST?......./N: ")
(setq ans(char-int(read-char)))
(if(= ans 10)(princ "Y")(read-char))
(if(or(= ans 78)(= ans 110))(setq ans nil)(setq ans 't))
(unless ans
(setf(aref *board* 138)0)
(pr "\n IS WHITE AT THE BOTTOM?......../N: ")
(let
((slct nil))
(setq slct (read-char))
(if(eql slct #\newline)(setq slct #\2)(read-char))
(if(or(eql slct #\N)(eql slct #\n))
(progn ;;BLACK-1st AT BOTTOM
;;;(setf(aref *board* 0)2);;;[0]
(fllrry zzz2 *board*)
;;;(setq *board* grdtbl2 *jmplst*);;????
)
(progn ;;WHITE-1st AT BOTTOM
;;;(setf(aref *board* 0)1);;[0]
(setq *board* grdtbl)
)
)
)
(pr "\n IS WHITE TO GO FIRST?........../N: ")
(let
((slct nil))
(setq slct (read-char))
(if(eql slct #\newline)(princ "Y")(read-char))
(if(or(eql slct #\N)(eql slct #\n))
(progn ;;BLACK FIRST
(setf(aref *board* 140)0)(setf(aref *board* 141)126) ;;BK-1st
(setf(aref *board* 142)0)(setf(aref *board* 143)126)
)
(progn ;;WHITE FIRST
(setf(aref *board* 140)126)(setf(aref *board* 141) 0) ;;WT-1st
(setf(aref *board* 142)126)(setf(aref *board* 143) 0)
)
)
)
(pr "\n IS ORAK-II TO PLAY.../N ")
(let
((slct nil))
(setq slct (read-char))
(if (eql slct #\newline)(PRINC "y")(read-char))
(if(or(eql slct #\N)(eql slct #\n))
(progn(setf(aref *board* 138)1))
(progn(setf(aref *board* 138)nil)) ;;computer to play
)
)
)
(unless ans ;;computer plays white
(setq *board* grdtbl2 *jmplst*);;????
(setf(aref *board* 138)nil)
(setf(aref *board* 140)126)(setf(aref *board* 141)0) ;;WT-1st
(setf(aref *board* 142)126)(setf(aref *board* 143)0)
)
)
(otherwise)
)
)
(pr "\n OPTIONS")
(pr "\n CHOOSE PLAY LEVEL (<3>-6): ")
(setq ans(char-int(read-char)))
(if(= ans 10)(princ "3")(read-char))
(if(or(<= ans 51)(>= ans 55))
(setf(aref *board* 139)51) ;;level=51-48=3
(setf(aref *board* 139)ans)
)
)
(setq *move* 0) ;;move-number INIT
(setq *krflg* '( ;;kings/rooks-moved-test-label-init
( -75 34 't 0 'nil) ;;kings-top
(-107 34 't 0 'nil)
( 75 104 't 0 'nil) ;;kins-bottom
( 107 104 't 0 'nil)
( -82 30 't 37 't) ;;Rooks-top
(-114 30 't 37 't)
( 82 100 't 107 't) ;;Rooks-bottom
( 114 100 't 107 't)
))
(setf(aref *board* 144)0) ;;top-ep
(setf(aref *board* 146)0) ;;bottom-ep
(mflgtst)
);;(menu-init)
(defun flgtst(x) ;; [flgtst 107/75/114/82-kKrR
(setq aa(assoc x *krflg*) z (caddr aa))
(pr "\n move-test assoc [~a] lst= ~a " x aa)
(when aa
(setq z1 (caddddr aa))
(pr "\n move-test z= ~a z1= ~a " z z1)
(when z
(when (/=(aref *board* (cadr aa))x)
(setq a (cdddr aa))
(setq b (reverse(cdddr(reverse aa))))
(setq a (list b 'nil a))
(setq *krflg* (subst a aa *krflg*) z nil)
)
)
(when z1 ;;[ 114 100 't 107 't]
(setq aa(assoc x *krflg*))
(when (/=(aref *board* (cadddr aa))x)
(setq a (reverse(cons 'nil (cdr (reverse aa)))))
(setq *krflg* (subst a aa *krflg*) z nil)
)
)
)
(setq z z)
)
(defun mflgtst() ;;moved-check
(setq *moves* (+ *moves* 1))
(flgtst -82) ;;topR wt
(flgtst 82) ;;botR
(flgtst -114) ;;topr bk
(flgtst 114) ;;botr
(flgtst -75) ;;topK wt
(flgtst 75) ;;botK
(flgtst -107) ;;topk bk
(flgtst 107) ;;botk
;; (pr "\n *krflg*= ~a\n" *krflg*)
(if(aref grdtbl 144)(pr "\n WTenpassant \n")) ;;address-top-ep
(if(aref grdtbl 146)(pr "\n BKenpassant \n")) ;;address-bot-ep
);;(mflgtst)
;;(read-line);;(read-char)
(defun scrn(x y z)
(pa)
(bgbrd x xxx)
; y x f1 f2
(prntdmap 28 0 1 ) ;;guarded-attacks high
(prntpmap (+ 11 28) 0 0) ;;top-side-attacks
(kngmap (+ 21 28) 0 0) ;;top-flags
;;(prntamap (+ 31 28) 0 1 ) ;;guards+attackers high
(prntcmap (+ 31 28) 0 0 ) ;;top-side
;;(prntdmap (+ 41 28) 0 ) ;;guarded-attacks
(prntfmap (+ 41 28) 0 0) ;;forks-attacks
(prntmap 28 11 1 ) ;;total-sq-values low
(prntpmap (+ 11 28) 11 80) ;;bottom-side
(kngmap (+ 21 28) 11 80) ;;bottom-flags
(prntsmap (+ 31 28) 11 ) ;;attacks(-)guards
;;(prntbd xxx (+ 41 28) 11 0 ) ;;all-toutches
(prntfmap (+ 41 28) 11 80) ;;forks-attacks
;; col=28 row=0/11 No-col low/high
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; (prntbd x 28 0 ) ;;char col 28 row 0
;; (prntamap 28 0 ) ;;attacks+guards
;; (prntsmap (+ 11 28) 0 ) ;;attacks-guards
;; (prntmap (+ 21 28) 0 ) ;;total-sq
;; (kngmap (+ 31 28) 0 0) ;;king-ray
;; (kngmap (+ 41 28) 0 80) ;;king-ray
;; (prntcmap 28 11 1 0) ;;top-side
;; (prntcmap (+ 11 28) 11 0 80) ;;bottom-side
;; (prntpmap (+ 21 28) 11 0) ;;top-attacks
;; (prntpmap (+ 31 28) 11 80) ;;bottom-attacks
;; (prntdmap (+ 41 28) 11 ) ;;guarded-attacks
;;;; (prntbd x (+ 41 28) 11 't 't)
;; col=28 row=0/11 No-col low/high
(goto-xy 28 21)
(pr "ÉÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍ» ")
(goto-xy 28 22)
(pr "º CHESS.LSP SEPT. 27,1996 º ")
(goto-xy 28 23)
(pr "º by: NICK K. VAN VLIET º ")
(goto-xy 28 24)
(pr "ÈÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍÍͼ")
);;(scrn *board*)
(defun shw()
(setq ff(open "err" :direction :output))
(scrn *board* *cmap* *pmap*)
(format ff "
*board*=\n ~a\n *cmap*=\n ~a\n *pmap*=\n ~a\n *amap*=\n ~a\n *smap*=\n ~a
*tmap*\n ~a\n *pthmap*=\n ~a\n *stack*=\n ~a\n *fork*=\n ~a\n"
*board* *cmap* *pmap* *amap* *smap*
*tmap* *pthmap* *stack* *fork*
)
)
;;[setq PAWN 1] [setq cnvrsn '[ ;;conversion val for LOAD.BD
;;[setq KNIGHT 3] [b 98] [B 66] [F 255]
;;[setq BISHOP 3] [r 114] [R 82] [48 0]
;;[setq ROOK 5] [n 110] [N 78] [f 255]
;;[setq QUEEN 9] [q 113] [Q 81] [0 0]
;;[setq KING 25] [k 107] [K 75]
;;VALUES [p 112] [P 80] ]]
;;(setq *debug* t)
;;138D DB 00 ,00 ;;.... .... .... .... ;;LOGO DEFINITION
;; DB 00 ,00 ;;.... .... .... ....
;; DB 07 ,0C0H ;;.... .*** **.. ....
;; DB 1DH,70H ;;...* **.* .*** ....
;; DB 31H,18H ;;..** ...* ...* *...
;; DB 21H,18H ;;..*. ...* ...* *...
;; DB 61H,2CH ;;.**. ...* ...* *...
;; DB 41H,44H ;;.*.. ...* .*.. .*..
;; DB 41H,84H ;;.*.. ...* *... .*..
;; DB 41H,04H ;;.*.. ...* .... .*..
;; DB 63H,8CH ;;.**. ..** *... **..
;; DB 25H,48H ;;..*. .*.* .*.. *...
;; DB 39H,38H ;;..** *..* ..** *...
;; DB 19H,30H ;;...* *..* ..** ....
;; DB 00 ,00 ;;.... .... .... ....
;; DB 00 ,00 ;;.... .... .... .... 13AD
;;l
;;1E50: DB 0A,0D,0A,0D,'OPTIONS'
;; DB 0A,0D,0A,0D
;; DB 'ANALYSE EACH MOVE.....................1 ',0A,0D,0A,0D
;; DB 'GO BACK A JUMP........................2 ',0A,0D,0A,0D
;; DB 'DISPLAY BEST JUMP.....................3 ',0A,0D,0A,0D
;; DB 'MAKE COMMENTS.........................4 ',0A,0D,0A,0D
;; DB 'WHICH IS YOUR SELECTION? $'
;;209B DB 0A,0D,0A,0D,'IS THIS FIGURE CORRECT ? $'
(defun lblr(x y) ;;create-move-&-exception-labels
;; id.fnctn-name
;; (pr "\n 4.1-lblr ~a for [~a]" y x);;(read-line)
(setq *label* (make-array 20)) ;;id-jmps
(setq *xlabel*(make-array 20)) ;;exceptions
(setq idlst (assoc x *jmplst*) name 'ERROR)
(if(symbolp x)
(setq exlst (assoc x *xcptnlst*))
(setq exlst (assoc (abs x) *xcptnlst*))
)
(when idlst
(setq name (car (reverse idlst)) val (car idlst) idlst (cdr idlst))
(setq nam2 (car (reverse exlst)) exlst (cdr exlst))
;(pr "\n 4.2-lblr ~a for [~4,a] chessman= ~8,a nam2= ~a "
; y x name nam2
;);;(read-line)
(do((kkk 0(1+ kkk)))((>= kkk 20))
(setq idlst (cdr idlst) lbl1 (car idlst))
(setq exlst (cdr exlst) lbl2 (car exlst))
(setf (aref *label* kkk) lbl1)
(setf (aref *xlabel* kkk) lbl2)
;;(unless(cdr idlst)(setq kkk 40))
)
;(when(eq y 'night-fork-sq)
; (pr "\n 4.3-lblr-~a for [~a] name=~a \n *label*=\n~a \n *xlabel*=\n~a"
; y x name *label* *xlabel*
; )(read-line)
;)
)
)
(defun epxmv(x y z &optional w)
;; w v x
(if w (pr "\n 8.1 EPX MADE-MOVE "))
)
(defun pwnp(x y &optional w) ;pawn-promotion
;; nwjmpvl
;(pr "\n 5.1.1 pwnp nwjmpvl= ~a " x);;(read-line)
(if (and(>= x (+ 65 (* 35 (- fctr))))(<= x (+ 72 (* 35 (- fctr)))))
(progn
(if(eq y 'str)(setf(aref *tmap* (fnf x t))(* 240 fctr)))
;;(goto-xy 30 22) ;;col/row
(pr "\n PAWN PROMOTION! >>>> INPUT /R/N/B: ")
(when w(setf(aref *tmap* (- x 30))(* (char-int(read-char)) fctr)));;???
)
)
)
(defun krmvdtst(x y) ;;king-rook-moved-test
;;idsq/frmsq
;(pr "\ n 6.1 krmvdtst member? assoc ~a *krflg* = ~a " x y);;(read-line)
(setq aa(assoc x *krflg*) z nil)
(if(member y aa)
(setq z (cadr (member y aa))) ;if not moved= 't
(setq z nil)
)
(setq z z)
)
(defun kngsrwmpty(x y w)
;; dirctn.Nosqs.frmsq
(setq a w zz 't)
(dotimes (kvv y)
(setq a (+ a x))
(if(/= (aref *board* a) 0)(setq zz nil))
)
)
(defun kngmvnchck(v x y s)
;; loctn.dirctn.fctr.label
(lblr 'pin 'kngmvchck)
(setq zz 't w (- v x))
(do((hh 1(+1 hh)))((> hh 3))
(setq w (+ w x))
(when zz
(do((kk 0(1+ kk)))((>= kk 4))
(setq jmp (aref *label* kk))
(setq nwsq w)
(do((kkk 1(1+ kkk)))((> kkk 8))
(setq nwsq(+ nwsq jmp))
(setq id(aref *board* nwsq))
(setq fr(/ id (abs id)))
(cond
((= id 0)nil)
((or(= id 255)(= fr y))(setq kk zl))
((= (- fr) y)
(if(or(= (abs id) 114)(= (abs id) 82) ;;rR
(= (abs id) 113)(= (abs id) 81) ;;qQ
)
(setq zz nil)
)
)
(t nil)
)
;(pr "\n 5.1.1.1 chckmap xi= ~a yj= ~a id=pk-board[30+~a]= ~a "
; (+ x i)(+ y j) sq id
;)
)
)
(when zz
(do((kk 4(1+ kk)))((>= kk 8))
(setq jmp (aref *label* kk))
(setq nwsq x)
(do((kkk 1(1+ kkk)))((> kkk 8))
(setq nwsq(+ nwsq jmp))
(setq id(aref *board* nwsq))
(setq fr(/ id (abs id)))
(cond
((= id 0)nil)
((or(= id 255)(= fr y))(setq kk zl))
((= (- fr) y)
(if(or(= (abs id) 98)(= (abs id) 66) ;;bB
(= (abs id) 113)(= (abs id) 81) ;;qQ
)
(setq zz nil)
)
)
(t nil)
)
;(pr "\n 5.1.1.2 chckmap xi= ~a yj= ~a id=pk-board[30+~a]= ~a "
; (+ x i)(+ y j) sq id
;)
)
)
)
)
)
(setq *label* s)
(setq zz zz)
)
(defun xfnctn(x y w v u r &optional s)
;; to-sq
;;xcptn.h+2.nwjmpvl.frmsq.idsq.fctr./move-needed
;;pawn-&-king-handling ###
;(when(eq name 'wpawn)
;(pr "
;5.1-xfnctn xcptn= ~a h+2= ~a w= ~a =?=top-ep ~a frmsq= ~a idsq= ~a fctr= ~a"
; x y w (aref *board* (+ 145 r))
; v u r
;);;(read-line)
;)
(cond
((eq x 'cstlg)
(cond
((and(or(= y 10)(= y 11))
(if(or
(krmvdtst u v) ;;member,assoc [idsq]=frmsq king-moved?
(krmvdtst ;;castle-moved?
(+ v (aref *label* (+ y 4)))
(aref *board* (+ v (aref *label* (+ y 4))))
)
(kngsrwmpty (aref *label* (- y 2)) (aref *label* (+ y 2)) v) ;;empty-row?
;; dirctn.Nosqs.frmsq
(kngmvnchck v (aref *label* (- y 2)) r *label*) ;;move-in-check-ok?
) ;; loctn.dirctn.fctr.label
(progn
(goto-xy 30 22)
(pr " <<<< CASTLEING >>>> ")
(setq z nil)
)
(setq z 't)
)
)
)
(t nil)
)
(setq z z)
)
((eq x 'str)
(if(and(= y 6)
(= (aref *board* w) 0)
)
(progn
(setq z nil)
(pwnp w x) ;;/nwjmpvl/-check pawn-promotion
)
(setq z 't)
)
)
((eq x 'pm) ;;nwjmpvl
(setq aa(aref *board* w))
;(if aa (pr "\n 5.1 xfnctn idsq= ~a 'pm= ~a" u aa));;(read-line)
(if(and(or(= y 4)
(= y 5)
)
(/= aa 255) ;;?????
)
(if(and(/= aa 0)(<(/ aa u)0)) ;;ocupied enemy
(progn ;;ok
(setq z nil) ;;ok
(princ " pm! ")
(pwnp w x) ;;/nwjmpvl/-check pawn-promotion
)
(if s
(setq z 't) ;;illegal-move
(setq z nil) ;;guarded-sq-on-map
)
)
(setq z 't) ;;illegal-move
)
)
((eq x 'ep)
;(pr "\n 5.2-xfnctn ??? x= ~a w= " x w)
;;id vl # # epx epx pm pm str ep -move
;;80 1 6 1 -1 1 -9 -11 -10 -20 10 wpawn
;; 0 1 2 3 4 5 6 7 8 lblr No
(if(and(= y 7)
(= (aref *board* w) 0) ;;nwjmpvl
(>= v (+ 65 (* 25 r))) ;;frmsq
(<= v (+ 72 (* 25 r)))
(= (aref *board* (- w (aref *label* 6))) 0)
)
(progn
(setq z nil)
(princ " ep! ")
)
(setq z 't)
)
)
((eq x 'epx)
(if(and(or(= y 2)(= y 3))
(= (aref *board* 152) w)
(/= w 0)
(= w (aref *board* (+ 145 r))) ;;top/bot-ep =62
)
(progn
(princ " epx! ")
;;(when s(epxmv w v x))
(setq id(aref *board* w))
(setq ww(+ w (aref *label* 6))) ;new-ep-loc-man
(setq aa (aref *pmap* (fnf ww t r)))
(setf(aref *pmap* (fnf ww t r))(cons v aa))
(setf (aref *board* 152) ww)
(setq z nil)
;(pr "\n 5.3 'epx frmsq= ~a id= ~a ww= ~a aa= ~a "
; v id ww (cons v aa)
;);;(read-line)
)
(setq z 't)
)
)
(t (setq z 't))
)
;;[if z [progn[xfnctn nwxcptn nwh2][setq z 't]][setq z nil]
;;EXCEPTIONS-TO-THE-RULE xcptnlst
;;;; 0 1 2 3 4 5 6 7 8 9 10
;; 80 1 6 1 epx epx pm pm str ep () pawn
;;112 1 6 1 epx epx pm pm str ep () pawn
;; 75 25 10 1 () () () () () () () () cstg cstg No No cstl cstl king
;;107 25 10 1 () () () () () () () () cstg cstg No No cstl cstl king
;;lblr No 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16
(if x (setq z z)(setq z nil))
)
(defun attack-map(&optional x) ;;returned-computer-move-list black king one move ;;==
; chess-move-on/off
(setq ii 0)
(do((i 30(1+ i)))((> i 108)) ;;find kings
(setq kng (aref *board* i)) ;;sq-i offset=30
(if(= kng 0)(setq fctr 0)(setq fctr (/ kng (abs kng))))
(cond
((or(= (abs kng) 107)(= (abs kng) 75)) ;;top/bottom-king
(setf(aref *board* (+ 135 fctr)) (list kng i))
(setq ii(1+ ii))
)
(t nil)
)
(when(> ii 1)(setq i zl))
)
(when(< ii 2)
(goto-xy 28 22)
(princ " >>> CHECKMATE! <<<");(read-line)
)
(setq sq(car(reverse(aref *board* 134)))) ;;top-king-square
(setq kng(car(aref *board* 134))) ;;king-id
;(pr "\n 3.0 top-king-found-~a peek[~a]= ~a = ~a "
; (car(reverse(assoc kng *jmplst*))) sq kng
; (int-char(abs kng))
;)
(pr "\n\n <<<< KING FOUND >>>\n");; (read-line);;--
(setq y(aref *board* 145)) ;;turn=+bottom/-top
(setq kngsq(car(reverse(aref *board* (+ 135 (- y))))))
(setq kng(car(aref *board* (+ 135 (- y))))) ;;opponent
(setq kname (car(reverse(assoc kng *jmplst*))))
(lblr 'pin 'attack-map-pin) ;;pin label
(setq fctr (* y (/ kng (abs kng)))) ;;side&loctn-factor
;(pr "\n 3.0.1 opponent-~a y= ~a kng= ~a fctr= ~a"
; kname y kng fctr
;)
(do((ii 0(1+ ii)))((>= ii 4)) ;;find pins-rook&queen-dirctn
(setq jmpvl (aref *label* ii)) ;;jump-val-No-directions
;(pr " \n 1 queen/rook-pin? jump-val=~a i=~a " jmpvl ii)
(setq flag 0)
(do((kk 1(1+ kk)))((> kk 8)) ;;No-jumps
(setq nwjmpvl (+ kngsq (* kk jmpvl))) ;;add-jmps-to-king-sq
(setq tsq(aref *board* nwjmpvl)) ;;to-sq-id
;(pr " \n 1 queen/rook-pin? flag=~a ii=~a kk=~a to-sq=~a newjmp=~a dist=~a "
; flag ii kk tsq nwjmpvl (* kk jmpvl)
;);; (read-line);;--
(cond
((= tsq 0) nil) ;;unoccupied-next-jump
((or(= tsq 255) ;;offside/defended-eject
(and(= flag 0)
(= (- tsq) (* fctr (abs tsq)))
)
)
(setq kk zl) ;;not-pinned-next-drection
)
((and(= flag 1)(= (- tsq)(* fctr (abs tsq)))) ;;pin-found-check
(cond
((or(= (abs tsq) 114)(= (abs tsq) 82) ;;R/r attacker
(= (abs tsq) 113)(= (abs tsq) 81) ;;Q/q attacker
)
(setq aa(aref *pmap* (fnf loctn t)))
(setf(aref *cmap* (fnf loctn t))255) ;;pin-stored
;(pr "
;3.1 queen/rook pin-found ~a=~a" name (fnf kngsq t)
;);; (read-line);;--
(setq kk zl flag 0) ;;done-pin-found
)
(t nil)
)
(setq kk zl) ;;next-dirctn
)
((= tsq (* fctr (abs tsq)))
(setq flag (1+ flag) loctn nwjmpvl)
(if(= flag 2)(setq kk zl))
) ;;own-man-found
(t nil)
)
)
)
(do((ii 4(1+ ii)))((>= ii 8)) ;;continue-find-pin-No-directns
(setq jmpvl (aref *label* ii)) ;;jump-val
(setq flag 0)
;(pr " \n 2 queen/bishop-pin? jump-val=~a " jmpvl)
(do((kk 1(1+ kk)))((> kk 8)) ;;No-jumps
(setq nwjmpvl (+ kngsq (* kk jmpvl))) ;;add-jmps-to-king-sq
(setq tsq(aref *board* nwjmpvl)) ;;to-sq-id
;(pr " \n 2 queen/bishop-pin? flag=~a ii=~a kk=~a to-sq=~a newjmp=~a dist=~a "
; flag ii kk tsq nwjmpvl (* kk jmpvl)
;);; (read-line);;--
(cond
((= tsq 0) nil) ;;unoccupied-next-jump
((or(= tsq 255) ;;offside/defended-eject
(and(= flag 0)
(= (- tsq) (* fctr (abs tsq)))
)
)
(setq kk zl) ;;not-pinned-next-drection
)
((and(= flag 1)(= (- tsq)(* fctr (abs tsq)))) ;;pin-found-check
(cond
((or(= (abs tsq) 98)(= (abs tsq) 66) ;;B/b attacker
(= (abs tsq) 113)(= (abs tsq) 81) ;;Q/q attacker
)
(setq aa(aref *pmap* (fnf loctn t)))
(setf(aref *cmap* (fnf loctn t))255) ;;pin-stored
;(pr " \n 2 queen/bishop-pin-found ~a=~a" name (fnf kngsq t))
;(read-line);;--
(setq kk zl flag 0) ;;done-pin-found
)
(t nil)
)
(setq kk zl) ;;next-dirctn
)
((= tsq (* fctr (abs tsq)))
(setq flag (1+ flag) loctn nwjmpvl)
(if(= flag 2)(setq kk zl))
) ;;own-man-found
(t nil)
)
)
)
(pr "\n <<< all pins found! >>>\n\n") ;; (read-line);;--
(do((ii 1(1+ ii)))((> ii 8)) ;;find a chessman-&-map
(do((kk 1(1+ kk)))((> kk 8))
(let*
((frmsq (grid kk ii)) ;;sqnum-board
(idsq (aref *board* frmsq)) ;;sq.-from
)
(if(= idsq 0) ;;y-is-for-comp
(setq fctr 0)
(setq fctr (/ idsq (abs idsq)))
)
(unless (or (= idsq 255)(= idsq 0) ;;unoccupied-ignored
(= (aref *cmap*(fnf frmsq t))255) ;;ignore-pin
)
(setf(aref *cmap* (grid kk ii (fnf)))frmsq);;comptr-sq-address
;;c-neg @0+ & p-pos @90+ address -level 1/2
(lblr idsq 'attack-map-sq) ;;chessman-id
;(pr "\n 3.1 ~a-map idsq= ~a frmsq= ~a ii= ~a kk= ~a"
; name idsq frmsq ii kk
;) (read-line);;--
(do((h 0(1+ h)))((>= h (aref *label* 0))) ;;No-directions-map-all-paths
(setq jmpvl (aref *label* (+ h 2))) ;;jump-val
(setq xcptn (aref *xlabel*(+ h 2))) ;;exceptions
;(pr "\n 3.2-~a-map
;*label*\n ~a\n HHmax= ~a id-sq= ~a from-sq= ~a jumpval= ~a h+2= ~a add= ~a"
; name
; *label* (aref *label* 0) idsq frmsq jmpvl (+ h 2)
; (+ jmpvl frmsq)
;); (read-line);;++
;(pr "\n 3.2.1-~a xcptn= ~a xfnctn= ~a"
; name xcptn
; (xfnctn xcptn (+ h 2) (+ jmpvl frmsq) frmsq idsq fctr)
; ;; to-sq
; ;;xcptn.h+2.nwjmpvl.frmsq.idsq.fctr./move-needed
;) (read-line)
(unless (and (symbolp xcptn)
(xfnctn xcptn (+ h 2) (+ jmpvl frmsq) frmsq idsq fctr)
;; to-sq
;;xcptn.h+2.nwjmpvl.frmsq.idsq.fctr./move-needed
) ;;check-all-exceptional-cases
(do((hh 1(1+ hh)))((> hh (aref *label* 1))) ;;No-jumps
(setq nwjmpvl (+ frmsq (* hh jmpvl))) ;;add-all-jmps-to-from-sq
(setq tsq(aref *board* nwjmpvl)) ;;to-sq-id
;(pr " \n 3.3 ~a-map from-sq=~a h=~a hh=~a to-sq=~a newjmp=~a dist=~a "
; name frmsq h hh tsq nwjmpvl (* hh jmpvl)
;)
(if(= tsq 255)
(setq hh zl) ;;offside-eject
(progn ;;tsq-sq-adrs
(setq rcl(aref *pmap*(* 1(fnf nwjmpvl t))))
(setf(aref *pmap*(* 1(fnf nwjmpvl t)))(cons frmsq rcl))
;; c-neg @0+ & p-pos @90+ attacked sqs level 3/4
;(pr "\n 3.4 ~a-cmap frmsq= ~a nwjmpvl= ~a \n ~a" name frmsq nwjmpvl
; (aref *cmap* (fnf nwjmpvl t(- fctr)))
;)
;(pr "\n 3.5 ~a-pmap = ~a" name
; (aref *pmap* (fnf nwjmpvl t(- fctr)))
;)
;(pr "\n 3.5.1 ~a-pmap = ~a" name
; (member frmsq (member 255 (aref *pmap* (fnf nwjmpvl t(- fctr)))))
;)
;(if(or(eq name 'wbishop)(eq name 'wqueen)
; (eq name 'bbishop)(eq name 'bqueen)
; );;(read-line)
;)
(cond
((= tsq 0) nil) ;;ok-next-jump
((= (aref *cmap* (fnf nwjmpvl t(- fctr)))255)
(if (member frmsq
(member 255
(aref *pmap* (fnf nwjmpvl t(- fctr)))
)
)
(progn
;(pr "\n 3.6 ~a-cmap frmsq= ~a nwjmpvl= ~a \n ~a" name frmsq nwjmpvl
; (aref *cmap* (fnf nwjmpvl t(- fctr)))
;)
;(pr "\n 3.7 ~a-pmap = ~a" name
; (member frmsq (member 255 (aref *pmap* (fnf nwjmpvl t(- fctr)))))
;);;(read-line)
() ;;pinner-ok-continue-esc-sq
)
(setq hh zl) ;;this is not the pinner stop
)
)
((and(=(- tsq)(* fctr (abs tsq))) ;;opp-king-continue-esc-sq
(or(=(abs tsq)107)(=(abs tsq)75))
)
nil
)
(t (setq hh zl)) ;;all-others-next-dirctn
)
)
) ;;if q b r & k continue/pawn cases/castle cases
;(pr "\n HIT ENTER")
;(read-line);;--
))
)
)
)
)
)
(if x (mflgtst))
)(attack-map)
(defun ttltmap() ;;total-@-sq
;; (setq *tmap* (make-array 180))
(rrynt *tmap*) ;180
(do((j 1(1+ j)))((> j 8))
(do((i 1(1+ i)))((> i 8))
(setq frmsq(grid i j))
(setq idfrmsq(aref *board* frmsq))
(setq frmsq(- frmsq 30))
(unless(= idfrmsq 0)
;(pr "\n 7.0.1 totaltmap i= ~a j= ~a idfrmsq=pk-board[30+~a]= ~a "
; i j frmsq idfrmsq
;)
(unless (and(not(aref *pmap* frmsq)) ;;not-empty-pmap
(not(aref *pmap*(+ frmsq 80))) ;;list
)
(if(= idfrmsq 0)(setq fctr 0)(setq fctr (/ idfrmsq (abs idfrmsq))))
(if (/= fctr 0) ;;this-sq-val
(progn ;;own-val-added-to-sq
(setq aa(assoc idfrmsq *jmplst*))
(setq idfrmval(cadr aa))
(setq name(car(reverse aa)))
(setq pkpf(aref *tmap* (fnf frmsq)))
(setf(aref *tmap* (fnf frmsq)) (+ pkpf idfrmval)) ;;loctn
)
(progn
(setq idfrmval 0)
(setq name 'empty)
(setq pkpf(aref *tmap* (fnf frmsq)))
)
)
;(pr "
;7.0.2 totaltmap ~a = ~a old-val= ~a poke-tmap[~af~a]= ~a" ;;once
; name idfrmval pkpf frmsq
; (fnf)
; (+ pkpf idfrmval)
;)(read-line)
(setq b (aref *pmap* frmsq )) ;;both-levels
(setq bb(aref *pmap* (+ frmsq 80)))
;(pr "
;7.0.3 totaltmap ~a [30+~a]
;list-b =peek-pmap[~af0]= ~a
;list-bb=peek-pmap[~af80]= ~a "
; name frmsq
; frmsq b
; frmsq bb
;)
(cond
((and(not(eq b nil))(not(eq bb nil)))(setq a (append b bb)))
((not(eq b nil))(setq a b))
((not(eq bb nil))(setq a bb))
(t(setq a nil))
)
;(pr "\n 7.0.4 LIST a= ~a car-a= [30+~a] " a (-(car a)30))
(when a
(setq len (length a))
(do((h 1(1+ h)))((> h len))
(setq tsq(car a)) ;;attacker/guard-by-sq
(setq idtsq(aref *board* tsq)) ;;attacker/guard
(setq tsq(- tsq 30))
(setq fctr1 (/ idtsq (abs idtsq))) ;;its-sign
(setq idtval (cadr (assoc idtsq *jmplst*))) ;;its-value
(setq nam2 (car (reverse(assoc idtsq *jmplst*)))) ;;its-name
(setq pkpf1(aref *tmap* (fnf frmsq nil fctr1)))
(setf(aref *tmap*(fnf frmsq nil fctr1))(+ idtval pkpf1));;att/grd
;(pr "
;7.0.5 ~a [~a]> ~a [~a]= ~a pk-board[30+~a] = ~a
; old-val= ~a ~a: poke-tmap[~af*~a]=new-val= ~a "
; name frmsq nam2 tsq idtval tsq idtsq
; pkpf1 nam2 frmsq (fnf nil nil fctr1)
; (+ pkpf1 idtval)
;)
(setq pkpf1(aref *tmap* (fnf tsq nil fctr1)))
(if(>(* fctr fctr1)0)
(progn
(setq nm 'guard:add_1 val (+ pkpf1 fctr1)) ;;add-guard-1
(setf(aref *tmap*(fnf tsq nil fctr1))val)
)
(progn
(setq nm 'enemy:val val (- pkpf1 idfrmval));;subtrct-enemy-val
(setf(aref *tmap*(fnf tsq nil fctr1))val)
)
)
;;;(setf(aref *tmap*(fnf tsq nil fctr1))
;;; (+ pkpf1 (* fctr1 (abs idfrmval))) ;;add-enemy/add-guard
;;;[or] (+ pkpf1 idfrmval) ;;subt-enemy/add-guard
;;;[or] (- pkpf1 idfrmval) ;;add-enemy/subt-guard
;;;)
;(pr "
;7.0.6-ttltmap ~a old-val= ~a poke-tmap[~af*~a]= ~a ~a"
; nam2 pkpf1
; tsq (fnf nil nil fctr1)
; val nm
;); (read-line)
(setq a (cdr a))
)
)
)
)
(when(= idfrmsq 0)
(setf(aref *tmap* frmsq)0)
(setf(aref *tmap* (+ frmsq 80))0)
)
)
)
)(ttltmap)
(defun nght_frk()
(dotimes(i 78)
;; (pr "\n 9.8 knight-fork-squares i= ~a " i)
(setq sq (+ i 30) id (aref *board* sq) flag nil)
(when(or(= (abs id) 78) ;N
(= (abs id) 110) ;n
) ;;opp-kng
(setq fctr (/ id (abs id)) kngsq (cadr(aref *board* (- 135 fctr))))
;; (pr "\n 9.8.1 ~a-fork-sq= ~a id= ~a kngsq= ~a" name sq id kngsq)
(lblr id 'night-fork-sq)
(do((j 2(1+ j)))((> j 9)) ;b-1st-ray-jmp-val
(setq jmp (aref *label* j))
(do((kvv 1(1+ kvv)))((> kvv 1)) ;1st-ray
(setq nwsq (+ sq (* kvv jmp)) flg 't)
;(pr "\n 9.8.2 ~a-fork-sq= ~a j= ~a jmp= ~a kvv= ~a nwsq= ~a flag= ~a "
; name sq j jmp kvv nwsq flag
;)
(when(and(> nwsq 29)(< nwsq 178))
(setq idnwsq(aref *board* nwsq))
(if(= idnwsq 255)(setq flg nil kvv zl))
(unless(= idnwsq 255)
(setq fctr1 (if(= idnwsq 0) 0 (/ idnwsq (abs idnwsq))))
(when(and(/= fctr1 0)(= 0 (+ fctr fctr1)))
(when(= kngsq nwsq)
(setf (aref *fork* (fnf sq t))(abs id))
(pr " >>> kingsq=nwsq")
;(read-line)
)
(if flag
(progn
(setq flag (1+ flag))
(when(> flag 0)
(setf (aref *fork* (fnf sq t))(abs id))
;(pr "\n 9.8.2.1 ~a-sq= ~a j= ~a nwsq= ~a idnwsq= ~a poke[~a],~a
;flag= ~a flg= ~a fctr= ~a fctr1= ~a kvv= ~a "
; name sq j nwsq idnwsq(fnf sq t)name
; flag flg fctr fctr1 kvv
;
;);
;(read-line)
)
)
(progn
(setq flag 0)
;(pr "\n 9.8.2.1 ~a-sq= ~a nwsq= ~a j= ~a
;flag=0= ~a flg= ~a fctr= ~a fctr1= ~a"
; name sq nwsq j
; flag flg fctr fctr1
;);
;(read-line)
)
)
)
;(pr "\n 9.8.3 ~a-fork-sq= ~a nwsq= ~a j= ~a flg= ~a " name sq nwsq j flg)
(when flg
(setq flag2 nil)
(do((jj 2(1+ jj)))((> jj 9)) ;b-2nd-ray-jmp-val
(setq jmp2 (aref *label* jj))
(do((nvv 1(1+ nvv)))((> nvv 1))
(setq nwsq2(+ nwsq (* nvv jmp2)))
;(pr "\n 9.8.3.1 ~a-fork-nwsq2= ~a jmp2= ~a
;sq= ~a j= ~a kvv= ~a jj= ~a nvv= ~a flag2= ~a "
; name nwsq2 jmp2
; sq j kvv jj nvv flag2
;) ;(read-line)
(when(and(> nwsq2 29)(< nwsq2 178))
(setq idnwsq2(aref *board* nwsq2))
(if(= idnwsq2 255)(setq nvv zl))
(unless(= idnwsq2 255)
(setq fctr2 (if(= idnwsq2 0) 0 (/ idnwsq2 (abs idnwsq2))))
(when(and(/= fctr2 0)(= 0 (+ fctr fctr2)))
(when(= kngsq nwsq2)
(setf (aref *fork* (fnf nwsq t))(abs id))
(pr " >>> kingsq=nwsq2")
;(read-line)
)
(if flag2
(progn
(setq flag2 (1+ flag2))
(when(> flag2 0)
(setf (aref *fork* (fnf nwsq t))(abs id))
;(pr "\n 9.8.3.2 ~a-sq= ~a nwsq2= ~a idnwsq2= ~a poke[~a],~a
;flag2= ~a flag= ~a flg= ~a fctr= ~a fctr2= ~a"
; name sq nwsq2 idnwsq2(fnf nwsq t)name
; flag2 flag flg fctr fctr2
;);
;(read-line)
)
)
(progn
(setq flag2 0)
;(pr "\n 9.8.3.2 ~a-sq= ~a nwsq= ~a nwsq2= ~a idnwsq2= ~a
;flag2=0= ~a flg= ~a fctr= ~a fctr2= ~a"
; name sq nwsq nwsq2 idnwsq2
; flag2 flg fctr fctr2
;);
;(read-line)
)
)
)
;(pr "\n 9.8.5 ~a-fork-sq= ~a nwsq2= ~a kvv= ~a nvv= ~a "
; name sq nwsq2 kvv nvv
;)
)
)
)
)
)
)
)
)
;; (read-line)
)
)
)
)
(defun nght_bshpsq()
;(pr "\n 9.7 knight/bishop-squares ")
(dotimes(i 78)
(setq sq (+ i 30) id (aref *board* sq) flag nil)
(when(or(= (abs id) 66) ;B
(= (abs id) 98) ;b
)
(setq a 5 flag 't)
)
(when(or(= (abs id) 78) ;N
(= (abs id) 110) ;n
) ;;opp-kng
(setq a 9 flag 't)
)
(when flag
(setq fctr (/ id (abs id)) kngsq (cadr(aref *board* (- 135 fctr))))
;(pr "\n 9.7.1 ~a-sq sq= ~a id= ~a kngsq= ~a" name sq id kngsq)
(lblr id 'knight/bishop-sq)
(do((j 2(1+ j)))((> j a)) ;b-1st-ray-jmp-val
(setq jmp (aref *label* j))
(do((kvv 1(1+ kvv)))((> kvv 7)) ;1st-ray
(setq nwsq (+ sq (* kvv jmp)) flg 't)
;(pr "\n 9.7.2 ~a-sq sq= ~a jmp= ~a kvv= ~a nwsq= ~a " name sq jmp kvv nwsq)
(unless(or(< nwsq 30)(> nwsq 178))
(if(=(aref *board* nwsq) 255)(setq flg nil kvv zl))
;(pr "\n 9.7.3 ~a-sq nwsq= ~a flg= ~a " name nwsq flg)
(when flg
(do((jj 2(1+ jj)))((> jj a)) ;b-2nd-ray-jmp-val
(setq jmp2 (aref *label* jj))
(do((nvv 1(1+ nvv)))((> nvv 7))
(setq nwsq2(+ nwsq (* nvv jmp2)))
(unless(or(< nwsq2 30)(> nwsq2 178))
(if(=(aref *board* nwsq2) 255)(setq nwsq2 zl nvv zl))
;(pr "\n 9.7.5 ~a-sq jmp2= ~a nwsq2= ~a nvv= ~a " name jmp2 nwsq2 nvv)
(when(= nwsq2 kngsq)
(setf(aref *pthmap* (fnf nwsq t))(abs id))
(setq nvv zl kvv zl flg nil)
;(pr " 9.7.6 ~a-sq poked[~a],~a " name nwsq (abs id));
;(read-line)
)
)
)
)
)
)
)
;(read-line)
)
)
)
)
(defun qnsq(x y z)
(setq id(aref *pthmap* (fnf (+ ksq x) t)))
(setq idd(aref *board* (+ ksq x)))
(unless(or(= id (abs kng))(= idd 255))
(setf (aref *pthmap* (fnf (+ ksq x) t(- fctr)))z)
)
(setq id(aref *pthmap* (fnf (+ ksq y) t)))
(setq idd(aref *board* (+ ksq y)))
(unless(or(= id (abs kng))(= idd 255))
(setf (aref *pthmap* (fnf (+ ksq y) t(- fctr)))z)
)
)
(defun qnsqmap(x)
(setq a (aref *board* (+ 135 x)) aa a kng (pop aa) ksq (pop aa))
(setq b (aref *board* (- 135 x)) b (pop b))
(setq fctr (/ kng (abs kng)) nwsq 0)
;(pr "\n 9.6 queen-squares ~a" a)
(while aa
(setq sq (pop aa) df (- sq ksq))
(cond
((= df -1)(qnsq 9 -11 (+ 6(abs b))))
((= df -10)(qnsq -9 -11 (+ 6(abs b))))
((= df 1)(qnsq -9 11 (+ 6(abs b))))
((= df 10)(qnsq 9 11 (+ 6(abs b))))
((= df -11)(qnsq -10 -1 (+ 6(abs b))))
((= df -9)(qnsq -10 1 (+ 6(abs b))))
((= df 11)(qnsq 10 1 (+ 6(abs b))))
((= df 9)(qnsq 10 -1 (+ 6(abs b))))
(t nil)
)
)
)
(defun escsq(x)
(setq a (aref *board* (+ 135 x)) aa a kng (pop aa) ksq (pop aa) escf 0)
;(pr "\n 9.5 escape-sq ~a" a)
(setq fctr (/ kng (abs kng)))
(lblr 'pin 'esc-sq)
(dotimes (i 8)
(setq nwsq (+ ksq (aref *label* i)))
(unless (or(< nwsq 30)(> nwsq 108))
(setq nwidsq (aref *board* nwsq))
(unless(= nwidsq 255)
(setq aa(aref *pmap* (fnf nwsq t(- fctr))))
;(pr "
;9.5.1 esc ~a ~a kng= ~a ksq= ~a nwidsq= ~a nwsq= ~a fctr= ~a\n aa= ~a "
; name nam2 kng ksq nwidsq nwsq fctr aa
;); (read-line)
(unless aa
(when (or(= nwidsq 0)(= nwidsq (* (abs nwidsq) (- fctr))))
; (pr "\n OK ")
(setq escf(1+ escf))
(setq a (reverse (cons nwsq (reverse a))))
(setf (aref *board* (+ 135 x)) a)
(setf (aref *pthmap* (fnf nwsq t))(abs kng))
)
)
)
)
)
;(pr "\n 9.5.2 escsq ~a ~a " escf a); (read-line)
(setf (aref *board* (+ 135 x))
(reverse (cons escf (reverse a)))
)
(qnsqmap x) ;+1=top-queen.opponent-king -1=bot-queen.opponent-king
(if (= escf 0) nil escf)
)
(defun ttksqr()
;(pr "\n 9.4 attack-square ")
(do((sq 30(1+ sq)))((> sq 108))
(setq id(aref *board* sq))
;(pr "\n 9.4.1 attack-square peek[30+~a]= ~a fctr= " (- sq 30) id)
(unless (or(= id 0)(= id 255))
(setq fctr (/ id (abs id)))
(when(member (abs id) '(75 107 78 110 80 112 66 98))
(setq aa (assoc id atk) len(-(length aa)3) a aa)
(setq z(popend aa) name (popend aa))
;(pr "\n 9.4.2 attack-sq aa= ~a len= ~a cadr-a= ~a " aa len(cadr a))
; K k N n P p B b
(dotimes(kvv len)
(setq a(cdr a) ln (abs(car a)) fctr2 (/ (car a) (abs(car a))) nwsq sq)
;(pr "\n 9.4.3 attack-square car-a= ~a len= ~a fctr2= ~a nwsq= ~a"
; (car a) ln fctr2 sq
;)
(setq flg 't)
(do((nvv 0(+ (if(< ln 10) 1 10) nvv)))((>= nvv ln))
(setq nwsq(+ nwsq (* fctr2 (if(< ln 10) 1 10))))
(if(or(< nwsq 30)(> nwsq 108))(setq flg nil))
(setq nwid(aref *board* nwsq))
(if(= nwid 255)(setq flg nil))
(unless flg (setq nvv zl))
;(pr "\n 9.4.4 att-sq ~a ~a [~a] kvv= ~a nvv ~a nwsq= ~a nwid= ~a flg= ~a"
; sq name id kvv nvv nwsq nwid flg
;)
)
(if flg (setf(aref *pthmap* (fnf nwsq t)) z))
)
)
)
)
)
(defun kngsqr(w z)
;; loctn.kfctr
;(pr "\n 9.3 king-square ")
(do((kvv -20(+ 10 kvv)))((> kvv 20))
(do((nvv -2(1+ nvv)))((> nvv 2))
(setq sq(+ w kvv nvv))
(setq id(aref *board* sq))
(when(and(/= id 255)(>= sq 30)(<= sq 108))
;(pr "\n 9.3.2 square id= ~a " id)
(when(or(= kvv 20)(= kvv -20)(= nvv 2)(= nvv -2))
(setf(aref *pthmap* (fnf sq t z)) 177)
)
)
)
)
)
(defun crss(w z)
;; loctn.kfctr
;(pr "\n 9.2 cross ")
(lblr 'pin 'rypth)
(let*
((kvv 0)
(nvv 0)
(idd 0)
(sqq 0)
)
(do((kvv 0(1+ kvv)))((>= kvv 4)) ;;only-cross-req-simplicity
(setq idd 255 sqq 0)
(do((nvv 1(1+ nvv)))((> nvv 9))
(setq jmp(aref *label* kvv))
(setq sq(+ w (* nvv jmp)))
(setq id(aref *board* sq))
(if(= id 255)
(progn
(setq nvv zl)
(when(/= idd 255)
;(pr "\n 9.2.2 cross id= ~a " id)
)
)
(progn
(when(and(>= sq 30)(<= sq 108))
(setf(aref *pthmap* (fnf sq t z)) 178)
)
)
)
)
)
)
)
(defun rypth(w z &optional (x nil s))
;; loctn.kfctr. again
;(pr "\n 9.1 ray-path king-found prt= ~a " s)
(lblr 'pin 'rypth)
(let*
((kvv 0)
(nvv 0)
(idd 0)
(sqq 0)
)
(do((kvv 4(1+ kvv)))((>= kvv 8)) ;;only-diag-req-simplicity
(setq idd 255 sqq 0 flg 't)
(do((nvv 1(1+ nvv)))((> nvv 9))
(setq jmp(aref *label* kvv))
(setq sq(+ w (* nvv jmp)))
(setq id(aref *board* sq))
;(pr "
;9.1.1 raypath i= ~a j= ~a lloc= ~a kfctr= ~a jmp= ~a
; id=pkbrd[30+~a]= ~a idd= ~a sqq= ~a flg= ~a"
; nvv kvv w z jmp
; (- sq 30) id idd sqq flg
;)
(when flg
(if(= id 255)
(progn
(setq flg nil nvv zl)
(when(/= idd 255)
;(pr "
; 9.1.2 raypath id= ~a flg= ~a z= ~a sqq= ~a s-switch= ~a "
; id flg z sqq x
;)
(when x
(setq bb(aref *board* (+ 135 (- z))) b(abs(pop bb)))
(setf(aref *pthmap* (fnf sqq t (- z))) (- b 9))
(rypth sqq z)
)
)
)
(progn
(when(and(>= sq 30)(<= sq 108))
(if x
(setf(aref *pthmap* (fnf sq t z)) 178)
(setf(aref *pthmap* (fnf sq t z)) 176)
)
)
(setq idd id sqq sq )
)
)
)
)
)
)
)
(defun kngsflg()
;; (setq *pthmap* (make-array 180))
(rrynt *pthmap*) ;180
(lblr 'pin 'kngsflg)
(dotimes(i 78)
(setq kng(aref *board* (+ i 30)))
(unless(or(= kng 0)(= kng 255))
(setq kfctr (/ kng (abs kng)))
;(pr "\n 9.0 raypath loc= ~a kfctr= ~a kng=pkbrd[30+~a]= ~a "
; (+ i 30) kfctr i kng
;)
(when(or(= (abs kng) 75)(= (abs kng) 107)) ;;K/k
(crss (+ i 30) kfctr ) ;;loctn.kfctr.-cross
(rypth (+ i 30) kfctr 't) ;;loctn.kfctr.again-diag
(kngsqr(+ i 30) kfctr ) ;;loctn.kfctr.-square
)
)
)
(ttksqr)
(escsq -1) ;esc-sq-top-king [-k=]
(escsq +1) ;esc-sq-bot-king []
;(nght_bshpsq)
(nght_frk)
)(kngsflg)
(push *board* *stack*) ;to-back-up-to-previous-board
(shw)
(read-line)(pr "\n STILL ON DRAWING BOARD! - HIT ENTER - line 2239 ") (read-line)
;; (menu-init)
)(chess ) ;;+++ok 't=inverse.'t=read-chr
;;original
(defun posib (&aux x) ;;returned-computer-move-list black king one move
(bdsgn (aref *board* 137))
(dotimes (ii 78) ;;80-2
(let*
(( i (+ ii 30) ) ;;sq-num-on-board
(sqval (aref *board* i)) ;;chessman square-val
)
(if(and (/= sqval 255)(/= sqval 0)(=(sign sqval)bdsgn)) ;;computer chessman top
(setf(aref **
(dolist (jmpt (goto i sqval t)) ;;jump-from-sq-i-to-list
(if(and (>=(aref *board* (cadr jmpt)) 0) ;;empty/opponent ok
(/=(aref *board* (cadr jmpt))255) ;;offside no
)
;; (setq x (cons jmpt x))
)
)
)
)
)))
(if(and
(not *bking-moved*)
(not *brook2-moved*)
(= (aref *board* 97) 0)
(= (aref *board* 98) 0)
(< (aref *human-square-control* 96) 1)
(< (aref *human-square-control* 97) 1)
(< (aref *human-square-control* 98) 1)
)
(setq x (cons 'oo x)) ;;castled king side
)
(if(and
(not *bking-moved*)
(not *brook1-moved*)
(= (aref *board* 95) 0)
(= (aref *board* 94) 0)
(equal (aref *board* 93) 0)
(< (aref *human-square-control* 96) 1)
(< (aref *human-square-control* 95) 1)
(< (aref *human-square-control* 94) 1)
)
(setq x (cons 'ooo x)) ;; ;;castled queen side
)
x ;;For each sq: return list of all jumps piece can make.
)
;; <<<<<<< MAIN >>>>>>>
(defun main()
(menu-init)
)
;;))))))(chess 1 't)
MAIN MENU
